{*
  Object Pascal simple dataset export manipulation routines
  @Author  Maciej Zagozda (1998-2008)
  @Licence Microsoft Reciprocal License (Ms-RL)
  @Website http://www.codeplex.com/intelitechdelphirtns/
  @Version 2008/04/20 Added documentation support
}

unit DataSetExportRoutines;

interface

uses
  Windows, Messages, SysUtils, Classes, Contnrs, Graphics, Controls, Forms, Dialogs, StdCtrls, DB;

type
  EDataSetXMLExporterInvalidDataSet = class(Exception);

  TDataSetXMLExporter = class
  private
    fDataSet: TDataSet;

    theSourceBuffer: PChar;
    theFileStream: TFileStream;

    procedure WriteFileHeader;
    procedure WriteFileFooter;
    procedure WriteString(strValue: AnsiString);
    procedure WriteRowStart(IsAddedTitle: Boolean);
    procedure WriteRowEnd(IsAddedTitle: Boolean);
    procedure WriteData(fld: TField; AString: ShortString);
    function GetFieldString(Field: TField): AnsiString;
  public
    constructor Create;
    destructor Destroy;
    procedure SaveToFile(const strFileName: AnsiString);
  published
    property DataSet: TDataSet read fDataSet write fDataSet;
  end;

implementation

constructor TDataSetXMLExporter.Create;
begin
  inherited;
end;

destructor TDataSetXMLExporter.Destroy;
begin
  inherited;
end;

procedure TDataSetXMLExporter.WriteFileHeader;

  function XMLFieldType(fld: TField): AnsiString;
  begin
    case fld.DataType of
      ftString: Result   := '"string" WIDTH="' + IntToStr(fld.Size) + '"';
      ftSmallint: Result := '"i4"'; //??
      ftInteger: Result  := '"i4"';
      ftWord: Result     := '"i4"'; //??
      ftBoolean: Result  := '"boolean"';
      ftAutoInc: Result  := '"i4" SUBTYPE="Autoinc"';
      ftFloat: Result    := '"r8"';
      ftCurrency: Result := '"r8" SUBTYPE="Money"';
      ftBCD: Result      := '"r8"'; //??
      ftDate: Result     := '"date"';
      ftTime: Result     := '"time"'; //??
      ftDateTime: Result := '"datetime"';
      else
    end;
    if fld.Required then Result := Result + ' required="true"';
    if fld.ReadOnly then Result := Result + ' readonly="true"';
  end;
var
  i: Integer;
begin
  WriteString('<?xml version="1.0" standalone="yes"?><!-- Generated by SMExport -->  <DATAPACKET Version="2.0">');
  WriteString('<METADATA><FIELDS>');

  with fDataset do
  begin
    for i := 0 to FieldCount - 1 do
    begin
      WriteString('<FIELD attrname="' + Fields[i].FieldName + '" fieldtype=' + XMLFieldType(Fields[i]) + '/>');
    end;
  end;//with

  WriteString('</FIELDS>');
  WriteString('<PARAMS DEFAULT_ORDER="1" PRIMARY_KEY="1" LCID="1033"/>');
  WriteString('</METADATA><ROWDATA>');
end;

procedure TDataSetXMLExporter.WriteFileFooter;
begin
  WriteString('</ROWDATA></DATAPACKET>');
end;

procedure TDataSetXMLExporter.WriteString(strValue: AnsiString);
begin
  StrPCopy(theSourceBuffer, strValue);
  theFileStream.Write(theSourceBuffer[0], StrLen(theSourceBuffer));
end;

procedure TDataSetXMLExporter.WriteRowStart(IsAddedTitle: Boolean);
begin
  if not IsAddedTitle then WriteString('<ROW');
end;

procedure TDataSetXMLExporter.WriteRowEnd(IsAddedTitle: Boolean);
begin
  if not IsAddedTitle then WriteString('/>');
end;

procedure TDataSetXMLExporter.WriteData(fld: TField; AString: ShortString);
begin
  if Assigned(fld) and (AString <> '') then WriteString(' ' + fld.FieldName + '="' + AString + '"');
end;

function TDataSetXMLExporter.GetFieldString(Field: TField): AnsiString;
  function GetDig(i, j: Word): AnsiString;
  begin
    Result := IntToStr(i);
    while (Length(Result) < j) do Result := '0' + Result;
  end;
var
  Hour, Min, Sec, MSec: Word;
begin
  case Field.DataType of
    ftBoolean: Result := UpperCase(Field.AsString);
    ftDate: Result    := FormatDateTime('yyyymmdd', Field.AsDateTime);
    ftTime: Result    := FormatDateTime('hhnnss', Field.AsDateTime);
    ftDateTime:
    begin
      Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
      DecodeTime(Field.AsDateTime, Hour, Min, Sec, MSec);
      if (Hour <> 0) or (Min <> 0) or (Sec <> 0) or (MSec <> 0) then Result := Result + 'T' + GetDig(Hour, 2) + ':' + GetDig(Min, 2) + ':' + GetDig(Sec, 2) + GetDig(MSec, 3);
    end//of
    else
    begin
      Result := Field.AsString;
    end;//of
  end;//case
end;


procedure TDataSetXMLExporter.SaveToFile(const strFileName: AnsiString);
var
  bkmark: TBookmark;
  i: Integer;
begin
  if not Assigned(fDataSet) then
  begin
    raise EDataSetXMLExporterInvalidDataSet.Create('DataSet needs to be assigned');
    Exit;
  end;//if

  theFileStream := TFileStream.Create(strFileName, fmCreate);
  theSourceBuffer := StrAlloc(1024);
  WriteFileHeader;

  with fDataSet do
  begin
    DisableControls;
    bkmark := GetBookmark;
    First;

    WriteRowStart(True);
    for i := 0 to FieldCount - 1 do WriteData(nil, Fields[i].DisplayLabel);
    WriteRowEnd(True);

    while (not EOF) do
    begin
      WriteRowStart(False);
      for i := 0 to FieldCount - 1 do WriteData(Fields[i], GetFieldString(Fields[i]));
      WriteRowEnd(False);

      Next;
    end;

    GotoBookmark(bkmark);
    EnableControls;
  end;

  WriteFileFooter;
  theFileStream.Free;
  StrDispose(theSourceBuffer);

end;

end.
